home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / codegen.lisp < prev    next >
Encoding:
Text File  |  1991-11-06  |  6.2 KB  |  193 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: codegen.lisp,v 1.15 91/08/25 18:14:00 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    The implementation-independent parts of the code generator.  We use
  15. ;;; functions and information provided by the VM definition to convert IR2 into
  16. ;;; assembly code.  After emitting code, we finish the assembly and then do the
  17. ;;; post-assembly phase.
  18. ;;;
  19. ;;; Written by Rob MacLachlan
  20. ;;;
  21. (in-package 'c)
  22.  
  23. (export '(component-header-length sb-allocated-size current-nfp-tn
  24.       callee-nfp-tn callee-return-pc-tn *code-segment* *elsewhere*
  25.       trace-table-entry pack-trace-table))
  26.  
  27. ;;;; Utilities used during code generation.
  28.  
  29. ;;; Component-Header-Length   --  Interface
  30. ;;; 
  31. (defun component-header-length (&optional (component *compile-component*))
  32.   "Returns the number of bytes used by the code object header."
  33.   (let* ((2comp (component-info component))
  34.      (constants (ir2-component-constants 2comp))
  35.      (num-consts (length constants)))
  36.     (ash (logandc2 (1+ num-consts) 1) vm:word-shift)))
  37.  
  38. ;;; SB-Allocated-Size  --  Interface
  39. ;;;
  40. (defun sb-allocated-size (name)
  41.   "The size of the Name'd SB in the currently compiled component.  Useful
  42.   mainly for finding the size for allocating stack frames."
  43.   (finite-sb-current-size (sb-or-lose name *backend*)))
  44.  
  45.  
  46. ;;; Current-NFP-TN  --  Interface
  47. ;;;
  48. (defun current-nfp-tn (vop)
  49.   "Return the TN that is used to hold the number stack frame-pointer in VOP's
  50.   function.  Returns NIL if no number stack frame was allocated."
  51.   (unless (zerop (sb-allocated-size 'non-descriptor-stack))
  52.     (let ((block (ir2-block-block (vop-block vop))))
  53.     (when (ir2-environment-number-stack-p
  54.        (environment-info
  55.         (block-environment block)))
  56.       (ir2-component-nfp (component-info (block-component block)))))))
  57.  
  58. ;;; CALLEE-NFP-TN  --  Interface
  59. ;;;
  60. (defun callee-nfp-tn (2env)
  61.   "Return the TN that is used to hold the number stack frame-pointer in the
  62.   function designated by 2env.  Returns NIL if no number stack frame was
  63.   allocated."
  64.   (unless (zerop (sb-allocated-size 'non-descriptor-stack))
  65.     (when (ir2-environment-number-stack-p 2env)
  66.       (ir2-component-nfp (component-info *compile-component*)))))
  67.  
  68.  
  69. ;;; CALLEE-RETURN-PC-TN  --  Interface
  70. ;;;
  71. (defun callee-return-pc-tn (2env)
  72.   "Return the TN used for passing the return PC in a local call to the function
  73.   designated by 2env."
  74.   (ir2-environment-return-pc-pass 2env))
  75.  
  76.  
  77. ;;;; Generate-code and support routines.
  78.  
  79. (defvar *trace-table-info*)
  80. (defvar *code-segment* nil)
  81. (defvar *elsewhere* nil)
  82.  
  83. ;;; Init-Assembler  --  Interface
  84. ;;; 
  85. (defun init-assembler ()
  86.   (setf *code-segment* (make-segment))
  87.   (setf *elsewhere* (make-segment))
  88.   (undefined-value))
  89.  
  90. (defvar *assembly-optimize* t
  91.   "Set to NIL to inhibit assembly-level optimization.  For compiler debugging,
  92.   rather than policy control.")
  93.  
  94. (defvar *assembly-check* nil
  95.   "Set to T to enable lifetime consistency checking of the assembly code.")
  96.  
  97. ;;; Generate-Code  --  Interface
  98. ;;;
  99. (defun generate-code (component)
  100.   (let ((prev-env nil)
  101.     (*trace-table-info* nil))
  102.     (do-ir2-blocks (block component)
  103.       (let ((1block (ir2-block-block block)))
  104.     (when (and (eq (block-info 1block) block)
  105.            (block-start 1block))
  106.       (assemble (*code-segment* nil)
  107.         (emit-label (block-label 1block)))
  108.       (let ((env (block-environment 1block)))
  109.         (unless (eq env prev-env)
  110.           (let ((lab (gen-label)))
  111.         (setf (ir2-environment-elsewhere-start (environment-info env))
  112.               lab)
  113.         (emit-label-elsewhere lab))
  114.           (setq prev-env env)))))
  115.  
  116.       (do ((vop (ir2-block-start-vop block) (vop-next vop)))
  117.       ((null vop))
  118.     (let ((gen (vop-info-generator-function (vop-info vop))))
  119.       (if gen 
  120.           (funcall gen vop)
  121.           (format t "Missing generator for ~S.~%"
  122.               (template-name (vop-info vop)))))))
  123.     
  124.     (assemble (*code-segment* nil)
  125.       (insert-segment *elsewhere*))
  126.     (expand-pseudo-instructions *code-segment*)
  127.     (when *assembly-check*
  128.       (segment-check-registers *code-segment* *elsewhere*))
  129.     
  130.     (when (and (policy (lambda-bind
  131.             (block-home-lambda
  132.              (block-next (component-head component))))
  133.                (or (>= speed cspeed) (>= space cspeed)))
  134.            *assembly-optimize*)
  135.       (optimize-segment *code-segment*))
  136.     (let ((length (finalize-segment *code-segment*)))
  137.       (values length (nreverse *trace-table-info*)))))
  138.  
  139. (defun emit-label-elsewhere (label)
  140.   (assemble (*elsewhere* nil)
  141.     (emit-label label)))
  142.  
  143. (defun label-elsewhere-p (label)
  144.   (<= (label-position *elsewhere*) (label-position label)))
  145.  
  146. (defun trace-table-entry (state)
  147.   (let ((label (gen-label)))
  148.     (emit-label label)
  149.     (push (cons label state) *trace-table-info*))
  150.   (undefined-value))
  151.  
  152. ;;; COMPUTE-TRACE-TABLE -- interface.
  153. ;;;
  154. ;;; Convert the list of (label . state) entries into an ivector.
  155. ;;; 
  156. (eval-when (compile load eval)
  157.   (defconstant bits-per-state 3)
  158.   (defconstant bits-per-entry 16)
  159.   (defconstant bits-per-offset (- bits-per-entry bits-per-state))
  160.   (defconstant max-offset (ash 1 bits-per-offset)))
  161. ;;;
  162. (defun pack-trace-table (table)
  163.   (declare (list table))
  164.   (let ((last-posn 0)
  165.     (last-state 0)
  166.     (result (make-array (length table)
  167.                 :element-type '(unsigned-byte #.bits-per-entry)))
  168.     (index 0))
  169.     (dolist (entry table)
  170.       (let* ((posn (label-position (car entry)))
  171.          (state (cdr entry)))
  172.     (flet ((push-entry (offset state)
  173.          (when (>= index (length result))
  174.            (setf result
  175.              (replace (make-array
  176.                    (truncate (* (length result) 5) 4)
  177.                    :element-type
  178.                    '(unsigned-byte #.bits-per-entry))
  179.                   result)))
  180.          (setf (aref result index)
  181.                (logior (ash offset bits-per-state)
  182.                    state))
  183.          (incf index)))
  184.       (do ((offset (- posn last-posn) (- offset max-offset)))
  185.           ((< offset max-offset)
  186.            (push-entry offset state))
  187.         (push-entry 0 last-state)))
  188.     (setf last-posn posn)
  189.     (setf last-state state)))
  190.     (if (eql (length result) index)
  191.     result
  192.     (subseq result 0 index))))
  193.